home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 9.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  18.6 KB  |  709 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "vars.h"
  11. #include "setprots.h"
  12. #include "errmsgprots.h"
  13. #include "miscprots.h"
  14. #include "smiscprots.h"
  15. #include "nodesprots.h"
  16. #include "dclmapprots.h"
  17. #include "chapprots.h"
  18.  
  19. void task_spec(Node task_node)                                /*;task_spec*/
  20. {
  21.     Node    entries_node, id_node;
  22.     int        anon;
  23.     Symbol    task_type_name, t_name, old_kind, entry_sym;
  24.     char    *id;
  25.     Declaredmap    entry_list;
  26.     Fordeclared fd1;
  27.  
  28.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  task_spec");
  29.  
  30.     id_node = N_AST1(task_node);
  31.     entries_node = N_AST2(task_node);
  32. #ifdef TBSN
  33.     /* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
  34.      * DS  9-22-86
  35.      */
  36.     opt_specs_node = N_AST3(task_node);
  37. #endif
  38.     /*
  39.      * If this is a task declaration, an anonymous task type is introduced
  40.      * for it. Entry declarations are always attached to the task type.
  41.      * TBSL : processing of specifications.
  42.      */
  43.     anon = (N_KIND(task_node) == as_task_spec);
  44.     id = N_VAL(id_node);
  45.     if (anon)
  46.         task_type_name =
  47.            find_new(strjoin(strjoin("task_type:", id), newat_str()));
  48.     else
  49.         task_type_name = find_type_name(id_node);
  50.  
  51.     if (task_type_name == symbol_any) return; /* Illegal redeclaration. */
  52.  
  53.     if (anon) {
  54. #ifdef TBSN
  55.         XREF lessf:= task_type_name;
  56. #endif
  57.     }
  58.     old_kind = TYPE_OF(task_type_name); /* may have been private */
  59.  
  60.     NATURE(task_type_name) = na_task_type_spec;
  61.     TYPE_OF(task_type_name) = task_type_name;
  62.     SIGNATURE(task_type_name) = tup_new(0);  /* created by the expander */
  63.     root_type(task_type_name) = task_type_name;
  64.     initialize_representation_info(task_type_name, TAG_TASK);
  65.     /* priv_types is {private, limited_private}; first arg to check_priv_decl
  66.      * is one of MISC_TYPE_ATTRIBUTES ...
  67.      */
  68.     if (old_kind == symbol_private)
  69.         check_priv_decl(TA_PRIVATE, task_type_name);
  70.     else if (old_kind == symbol_limited_private)
  71.         check_priv_decl(TA_LIMITED_PRIVATE, task_type_name);
  72.     if (anon) {
  73.         t_name = find_new(id);
  74.         NATURE(t_name) = na_task_obj_spec;
  75.         TYPE_OF(t_name) = task_type_name;
  76.         SIGNATURE(t_name) = (Tuple) 0;
  77.         N_UNQ(task_node) = t_name;
  78.     }
  79.  
  80.     N_TYPE(task_node) = task_type_name;
  81.     newscope(task_type_name);    /* introduce new scope */
  82. #ifdef TBSN
  83.     prefix := prefix + id + '.';            $ For unique names.
  84. #endif
  85.         sem_list(entries_node);
  86. #ifdef TBSN
  87.     /* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
  88.      * DS  9-22-86
  89.      */
  90.     sem_list(opt_specs_node);
  91. #endif
  92.  
  93.     entry_list = DECLARED(scope_name);
  94.     popscope();
  95.  
  96.     if (anon) {
  97.         /* Attach entry declarations for task object as well, and emit a
  98.          * declaration for the task object itself.
  99.          */
  100.         SIGNATURE(t_name) = (Tuple) 0;
  101.         DECLARED(t_name) = entry_list;
  102.  
  103.         FORDECLARED(id, entry_sym, entry_list, fd1)
  104.             /*(for entry = entry_list(id))*/
  105.             SCOPE_OF(entry_sym) = t_name;
  106.         ENDFORDECLARED(fd1)
  107.     }
  108.     return;
  109. }
  110.  
  111. void accept_statement(Node accept_node)                    /*;accept_statement*/
  112. {
  113.  
  114.     /* This procedure opens a new scope when an ACCEPT statement is seen.
  115.      * In the case of an overloaded entry name, it selects the one with
  116.      * the matching signature.
  117.      */
  118.  
  119.     int        certain;
  120.     Symbol    task_name, task_type, real_name, entry_name, ix_t;
  121.     Set        entries;
  122.     Tuple    formals;
  123.     Forset    fs1;
  124.     Node    id_node, indx, body_node;
  125.     Node    formals_node;
  126.     int        exists, nat;
  127.     char    *id, *junk;
  128.     Fortup    ft1;
  129.  
  130.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : accept_statement");
  131.  
  132.     id_node = N_AST1(accept_node);
  133.     indx = N_AST2(accept_node);
  134.     formals_node = N_AST3(accept_node);
  135.     body_node = N_AST4(accept_node);
  136.  
  137.     id = N_VAL(id_node);
  138.     formals = get_formals(formals_node, id);
  139.     /* Find the task  in which the accept statement occurs. The accept
  140.      * may of course appear within a block or another accept statement.
  141.      */
  142.  
  143.     exists    = FALSE;
  144.     FORTUP(task_name = (Symbol), open_scopes, ft1);
  145.         nat = NATURE(task_name);
  146.         if( nat != na_block && nat != na_entry && nat != na_entry_family) {
  147.             exists = TRUE;
  148.             break;
  149.         }
  150.     ENDFORTUP(ft1);
  151.     certain = exists;
  152.     task_type = TYPE_OF(task_name);
  153.  
  154.     if (task_type == (Symbol)0 || NATURE(task_type) != na_task_type)  {
  155. #ifdef ERRNUM
  156.         errmsgn(455, 321, accept_node);
  157. #else
  158.         errmsg("Accept statements can only appear in tasks","9.5", accept_node);
  159. #endif
  160.         /* following junk line in SETL not needed here    ds 1 nov 84
  161.          * entry_name = id;
  162.          */
  163.         return;
  164.     }
  165.  
  166.     real_name = entry_name = dcl_get(DECLARED(task_name), id);
  167.  
  168.     if (entry_name == (Symbol)0) {
  169. #ifdef ERRNUM
  170.         errmsgn(456, 321, id_node);
  171. #else
  172.         errmsg("Undefined entry name in ACCEPT ", "9.5", id_node);
  173. #endif
  174. #ifdef TBSL
  175.         -- entry_name is symbol, id is string        ds 2-jan-85
  176.             entry_name = id; /* For dummy scope. */
  177. #endif
  178.         return; /* to Initialize it . */
  179.     }
  180.     else if (NATURE(entry_name) == na_entry) {
  181.         /* Collect all its overloadings and select the one with the
  182.          * correct signature.
  183.          */
  184.         entries = OVERLOADS(entry_name);
  185.  
  186.         if (indx != OPT_NODE) {
  187. #ifdef ERRNUM
  188.             errmsgn(457, 321, indx);
  189. #else
  190.             errmsg("invalid index on entry (not entry family)", "9.5", indx);
  191. #endif
  192.         }
  193.  
  194.         exists = FALSE;
  195.         FORSET(entry_name = (Symbol), entries, fs1);
  196.             if (same_sig_spec(entry_name, formals)) {
  197.                 exists = TRUE;
  198.                 break;
  199.             }
  200.         ENDFORSET(fs1);
  201.         if (!exists) {
  202. #ifdef ERRNUM
  203.             errmsgn(458, 321, id_node);
  204. #else
  205.             errmsg("Entry name in ACCEPT statement does not match any entry" ,
  206.               "9.5", id_node);
  207. #endif
  208.             return;
  209.         }
  210.     }
  211.     else if (NATURE(entry_name) == na_entry_family) {
  212.         ix_t = (Symbol) index_type(TYPE_OF(entry_name));
  213.  
  214.         if (indx == OPT_NODE) {
  215. #ifdef ERRNUM
  216.             errmsgn(459, 321, accept_node);
  217. #else
  218.             errmsg("Missing index for entry family.", "9.5", accept_node);
  219. #endif
  220.         }
  221.         else {
  222.             adasem(indx);
  223.             check_type(ix_t, indx);
  224.         }    
  225.     }
  226.     else {
  227. #ifdef ERRNUM
  228.         errmsgn(460, 321, id_node);
  229. #else
  230.         errmsg("Invalid entry name in ACCEPT", "9.5", id_node);
  231. #endif
  232.         return;
  233.     }
  234.  
  235.     N_UNQ(id_node) = entry_name;
  236.     TO_XREF(entry_name);
  237.  
  238.     reprocess_formals(entry_name, formals_node);
  239.     if (in_open_scopes(entry_name )) {
  240. #ifdef ERRNUM
  241.         l_errmsgn(461, 462, 321, accept_node);
  242. #else
  243.         errmsg_l("An accept_statement cannot appear within an ACCEPT for",
  244.           " the same entry", "9.5", accept_node);
  245. #endif
  246.     }
  247.     newscope(entry_name);
  248.     has_return_stk = tup_with(has_return_stk, (char *)FALSE);
  249.     adasem(body_node);
  250.     junk = tup_frome(has_return_stk);
  251.     popscope();
  252. }
  253.  
  254. void entry_decl(Node entry_node)                            /*;entry_decl*/
  255. {
  256.     /* An entry declaration is treated like a procedure specification.
  257.      * An anonymous type is created for the entry object. This type is
  258.      * used by the interpreter to build the environment of an entry.
  259.      */
  260.  
  261.     Symbol    entry_sym, entry_type;
  262.     Node    id_node, formal_list;
  263.     Tuple    formals;
  264.  
  265.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  entry_decl");
  266.  
  267.     id_node = N_AST1(entry_node);
  268.     formal_list = N_AST2(entry_node);
  269.  
  270.     formals = get_formals(formal_list, N_VAL(id_node));
  271.  
  272.     check_out_parameters(formals);
  273.  
  274.     /*entry = chain_overloads(N_VAL(id_node), [na_entry, 'none', formals]); */
  275.     entry_sym = chain_overloads(N_VAL(id_node), na_entry, symbol_none,
  276.       formals, (Symbol)0, formal_list);
  277.  
  278.     entry_type = anonymous_type();
  279.  
  280.     /*SYMBTAB(entry_type) := [na_entry_former, scope_name, signature(entry)]; */
  281.     NATURE(entry_type) = na_entry_former;
  282.     TYPE_OF(entry_type) = scope_name;
  283.     SIGNATURE(entry_type) = SIGNATURE(entry_sym);
  284.     root_type(entry_type) = entry_type;
  285.  
  286.     N_UNQ(id_node)    = entry_sym;
  287.     N_TYPE(entry_node) = entry_type;
  288. }
  289.  
  290. void entry_family_decl(Node entry_node)                    /*;entry_family_decl*/
  291. {
  292.     /* An entry family  is not  an overloadable  object. It     is  constructed
  293.      * as an array of entries. An anonymous type is introduced for the entry
  294.      * former, just     as for an  entry declaration, and another is introduced
  295.      * for the array representing the family.
  296.      */
  297.  
  298.     Symbol    entry_sym, entry_type, family_type;
  299.     Symbol    opt_range;
  300.     Tuple    formals, f, tup;
  301.     Node    id_node, discrete_range, formal_list;
  302.  
  303.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_family_decl");
  304.  
  305.     id_node = N_AST1(entry_node);
  306.     discrete_range = N_AST2(entry_node);
  307.     formal_list = N_AST3(entry_node);
  308.  
  309.     entry_sym = find_new(N_VAL(id_node));
  310.  
  311.     formals = get_formals(formal_list, N_VAL(id_node));
  312.  
  313.     check_out_parameters(formals);
  314.  
  315.     f = process_formals(entry_sym, formals, TRUE);
  316.  
  317.     entry_type = anonymous_type();
  318.  
  319.     NATURE(entry_type) = na_entry_former;
  320.     TYPE_OF(entry_type) = scope_name;
  321.     SIGNATURE(entry_type) = f;
  322.     root_type(entry_type) = entry_type;
  323.     adasem(discrete_range);
  324.     opt_range = make_index(discrete_range);
  325.     family_type = anonymous_type();
  326.     /* SYMBTAB(family_type) =
  327.      *        [na_array, family_type, [[opt_range], entry_type]];
  328.      */
  329.     NATURE(family_type) = na_array;
  330.     TYPE_OF(family_type) = family_type;
  331.     tup = tup_new(2);
  332.     tup[1] = (char *) tup_new1((char *) opt_range);
  333.     tup[2] = (char *) entry_type;
  334.     SIGNATURE(family_type) = (Tuple) tup;
  335.     root_type(family_type) = family_type;
  336.  
  337.     /* SYMBTAB(entry) = [na_entry_family, family_type, f]; */
  338.     NATURE(entry_sym) = na_entry_family;
  339.     TYPE_OF(entry_sym) = family_type;
  340.     SIGNATURE(entry_sym) = f;
  341.     formal_decl_tree(entry_sym) = (Symbol) formal_list;
  342.     N_UNQ(id_node) = entry_sym;
  343.     N_TYPE(entry_node) = family_type;
  344. }
  345.  
  346. void entry_call(Node node)                                    /*;entry_call*/
  347. {
  348.     /* process an entry call. obj_node below is the entry name: either a se-
  349.      * lected or an indexed expression.
  350.      */
  351.  
  352.     Symbol    range_typ, entry_sym;
  353.     Node    obj_node, arg_list_node;
  354.     Tuple    arg_list;
  355.     Node    task_node, index_node, entry_node;
  356.  
  357.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  entry_call");
  358.  
  359.     obj_node = N_AST1(node);
  360.     arg_list_node = N_AST2(node);
  361.  
  362.     arg_list = N_LIST(arg_list_node);
  363.  
  364.     find_entry_name(obj_node); /* Normalize entry name*/
  365.     task_node = N_AST1(obj_node);
  366.     entry_node = N_AST2(obj_node);
  367.  
  368.     if (entry_node == OPT_NODE) return;    /* previous error. */
  369.  
  370.     if (N_KIND(obj_node) == as_entry_family_name) {
  371.         entry_sym = N_UNQ(entry_node);
  372.         range_typ = (Symbol) index_type(TYPE_OF(entry_sym));
  373.         index_node = N_AST3(obj_node);
  374.  
  375.         if (index_node == OPT_NODE) {
  376.             /* Case of a call to a parameterless family. The formals list
  377.              * is actually the index expression. Verify its size.
  378.              */
  379.             if (tup_size(arg_list) != 1) {
  380. #ifdef ERRNUM
  381.                 errmsgn(463, 464, obj_node);
  382. #else
  383.                 errmsg("Call to member of entry family requires one index",
  384.                   "9.5, 3.6.1", obj_node);
  385. #endif
  386.                 return;
  387.             }
  388.             else {
  389.                 index_node = (Node) arg_list[1];
  390.                 N_AST3(obj_node) = index_node;
  391.  
  392.                 arg_list_node = node_new(as_list);
  393.                 N_LIST(arg_list_node) = tup_new(0);
  394.  
  395.                 N_AST2(node) = arg_list_node;
  396.             }
  397.         }
  398.  
  399.         check_type(range_typ, index_node);
  400.  
  401.         /* process as usual call.*/
  402.         N_NAMES(obj_node) = set_new1((char *) entry_sym);
  403.         check_type(TYPE_OF(entry_sym), node);
  404.         N_AST3(obj_node) = index_node;     /* restore index */
  405.         N_KIND(obj_node) = as_entry_name;  /* common processing after this */
  406.     }
  407.     else {    /* Simple entry.*/
  408.         check_type(symbol_none, node);    /* as for a procedure call */
  409.         entry_sym = N_UNQ(entry_node);
  410.         N_AST3(obj_node) = OPT_NODE;      /* discard  N_NAMES  */
  411.     }
  412.     /*  Having resolved the call, use the unique entry name to complete the
  413.      *  resolution of the task name itself.
  414.      */
  415.     if (entry_sym != (Symbol)0)
  416.         complete_task_name(task_node, TYPE_OF(SCOPE_OF(entry_sym)));
  417.  
  418.     return;
  419. }
  420.  
  421. void check_entry_call(Node stat_node)                    /*;check_entry_call*/
  422. {
  423.     /* Verify that the call in a timed entry call or a conditional entry call
  424.      * is indeed a call to an entry, and not to a procedure.
  425.      */
  426.  
  427.     adasem(stat_node);
  428.  
  429.     if (N_KIND(stat_node) == as_call) {
  430. #ifdef ERRNUM
  431.         errmsgn(466, 467, stat_node);
  432. #else
  433.         errmsg("context requires entry name ", "9.7.2, 7.3", stat_node);
  434. #endif
  435.     }
  436. }
  437.  
  438. void find_entry_name(Node obj_node)                        /*;find_entry_name*/
  439. {
  440.     /* Find the name of an entry or entry family, given by a qualified and
  441.      * (in the case of a family) indexed expression. This differs from other
  442.      * cases of name resolution in that the name of the task containing the
  443.      * entry can be given by an expression that must also be resolved.
  444.      * This procedure is also called to validate the argument of the COUNT
  445.      * attribute; this attribute can only be used within the task body, in
  446.      * which the entry need not be named as a selected component. An entry
  447.      * name will then be seen as an overloaded identifier. The task name is
  448.      * the scope of the entry.
  449.      * An entry family name is built as a triple [task_node, entry_node, index]
  450.      * An entry name is built as a pair [task_node, entry_name]. In addition,
  451.      * the N_NAMES field is defined in the case of entries, which can be over-
  452.      * loaded.
  453.      */
  454.  
  455.     Node    index_list_node, task_node, entry_node, index_node;
  456.     Tuple    index_list;
  457.     Symbol    obj, task_name, t, e, sym;
  458.     Set        entries, task_types, entry_names;
  459.     Forset    fs1, fs2;
  460.     char    *entry_id;
  461.     int exists, is_family;
  462.  
  463.     if (cdebug2 > 3 ) TO_ERRFILE("AT PROC :  find_entry_name");
  464.  
  465.     if (N_KIND(obj_node) == as_simple_name) {
  466.         if (N_OVERLOADED(obj_node) ) {
  467.             entries = N_NAMES(obj_node);
  468.             task_name = SCOPE_OF((Symbol)set_arb( entries));
  469.  
  470.             if (!is_task_type(TYPE_OF(task_name))) {
  471. #ifdef ERRNUM
  472.                 errmsgn(468, 321, obj_node);
  473. #else
  474.                 errmsg("Invalid entry name", "9.5", obj_node);
  475. #endif
  476.                 entry_node = OPT_NODE;
  477.             }
  478.             else {
  479.                 entry_node = copy_node(obj_node);
  480.             }
  481.  
  482.             task_node = node_new(as_simple_name);
  483.             N_UNQ(task_node) = task_name;
  484.             N_VAL(task_node) = (char *) original_name(task_name);
  485.             copy_span(obj_node, task_node);
  486.  
  487.             index_node = OPT_NODE;
  488.         }
  489.         else if (NATURE((obj = N_UNQ(obj_node))) == na_entry_family) {
  490.             /* Member of entry family, with index missing. */
  491. #ifdef ERRNUM
  492.             errmsgn(469, 321, obj_node);
  493. #else
  494.             errmsg("Missing index in name of member of entry family",
  495.               "9.5", obj_node);
  496. #endif
  497.             entry_node = OPT_NODE;
  498.         }
  499.     }
  500.     else if (N_KIND(obj_node) == as_selector) { /* selected_component*/
  501.         task_node = N_AST1(obj_node);
  502.         entry_node = N_AST2(obj_node);
  503.         index_node = OPT_NODE;
  504.     }
  505.     else {    /* case of entry family. */
  506.         entry_node = N_AST1(obj_node);
  507.         index_list_node = N_AST2(obj_node);
  508.  
  509.         if (N_KIND(entry_node) == as_simple_name) {
  510.             /* Entry family named in task body. Get enclosing task name.*/
  511.  
  512.             task_node = node_new(as_simple_name);
  513.             task_name = SCOPE_OF(N_UNQ(entry_node));
  514.             N_UNQ(task_node) = task_name;
  515.             N_VAL(task_node) = (char *) original_name(task_name);
  516.             copy_span(obj_node, task_node);
  517.         }
  518.         else {/* Name is selected component. */
  519.             task_node = N_AST1(entry_node);
  520.             entry_node = N_AST2(entry_node);
  521.         }
  522.  
  523.         index_list = N_LIST(index_list_node);
  524.         if (tup_size(index_list) != 1) {
  525. #ifdef ERRNUM
  526.             errmsgn(470, 464, obj_node);
  527. #else
  528.             errmsg("Member of entry family requires a single index ",
  529.               "9.5, 3.6.1", obj_node);
  530. #endif
  531.             entry_node = OPT_NODE;
  532.         }
  533.         index_node = (Node) index_list[1];/* In any case. */
  534.     }
  535.  
  536.     if (entry_node != OPT_NODE) {        /* no previous error*/
  537.         valid_task_name(task_node);
  538.         task_types = N_PTYPES(task_node);
  539.         if (set_size(task_types) == 0)        /* prefix is not a task*/
  540.             entry_node = OPT_NODE;
  541.     }
  542.     else {
  543.         task_node = OPT_NODE;
  544.         task_types = set_new(0);
  545.     }
  546.  
  547.     entry_names = set_new(0);
  548.     entry_id = (char *) N_VAL(entry_node);
  549.     is_family = FALSE;
  550.  
  551.     FORSET(t = (Symbol), task_types, fs1);
  552.         if (is_access(t)) t = (Symbol) designated_type(t);
  553.  
  554.         e = dcl_get(DECLARED(t), entry_id);
  555.         if (e != (Symbol)0) {
  556.             if (NATURE(e) == na_entry) {
  557.                 FORSET(sym = (Symbol), OVERLOADS(e), fs2);
  558.                     entry_names = set_with(entry_names, (char *) sym);
  559.                 ENDFORSET(fs2);
  560.             }
  561.             else {    /* name of entry family*/
  562.                 entry_names = set_with(entry_names, (char *) e);
  563.                 is_family = TRUE;
  564.             }
  565.         }
  566.     ENDFORSET(fs1);
  567.  
  568.     if (set_size(entry_names) == 0 && entry_node != OPT_NODE ) {
  569. #ifdef ERRNUM
  570.         errmsgn(471, 321, obj_node);
  571. #else
  572.         errmsg("Undefined entry name in task : ", "9.5", obj_node);
  573. #endif
  574.         entry_node = OPT_NODE;
  575.     }
  576.     else {
  577.         exists = FALSE;
  578.         if (set_size(entry_names) > 1 ) {
  579.             exists = FALSE;
  580.             FORSET(e = (Symbol), entry_names, fs2);
  581.                 if (NATURE(e) == na_entry_family ) {
  582.                     exists = TRUE;
  583.                     break;
  584.                 }
  585.             ENDFORSET(fs2);
  586.         }
  587.         if (exists) {
  588. #ifdef ERRNUM
  589.             id_errmsgn(472, e, 321, obj_node);
  590. #else
  591.             errmsg_id("ambiguous entry family name: %", e , "9.5", obj_node);
  592. #endif
  593.             /* entry is undefined, this is a guess (gs sep 20) */
  594.             entry_node = OPT_NODE;
  595.         }
  596.         else if (entry_node != OPT_NODE) {
  597.             if (is_family) {
  598.                 N_KIND(obj_node)  = as_entry_family_name;
  599.                 N_UNQ(entry_node) = (Symbol)set_arb(entry_names);
  600.                 N_AST3(obj_node)  = index_node;
  601.             }
  602.             else {
  603.                 N_KIND(obj_node)  = as_entry_name;
  604.                 N_NAMES(obj_node) = entry_names;
  605.                 if (index_node != OPT_NODE ) {
  606. #ifdef ERRNUM
  607.                     id_errmsgn(465, (Symbol)set_arb(entry_names), 321, obj_node);
  608. #else
  609.                     errmsg_id("invalid index. % is not an entry family", 
  610.                         (Symbol) set_arb(entry_names), "9.5", obj_node);
  611. #endif
  612.                 }
  613.  
  614.             }
  615.         }
  616.     }
  617.     N_AST1(obj_node) = task_node;
  618.     N_AST2(obj_node) = entry_node;
  619. }
  620.  
  621. void terminate_statement(Node node)                    /*;terminate_statement*/
  622. {
  623.     /* A terminate alternative is annotated with the nesting level of the
  624.      * statement, to simplify the retrieval of the task environment.
  625.      */
  626.  
  627.     int    certain, exists, i, out_depth, j, blktyp;
  628.     Fortup    ft1;
  629.     Symbol    scope;
  630.  
  631.     exists = TRUE;
  632.     FORTUPI(scope = (Symbol), open_scopes, i, ft1);
  633.         if (NATURE(scope) == na_task_obj || NATURE(scope) == na_task_type) {
  634.             exists = TRUE;
  635.             break;
  636.         }
  637.     ENDFORTUP(ft1);
  638.     certain = exists;
  639.     if (!certain) {
  640. #ifdef ERRNUM
  641.         errmsgn(473, 474, node);
  642. #else
  643.         errmsg("Invalid context for TERMINATE alternative", "9.7.1", node);
  644. #endif
  645.         i = 1;
  646.     }
  647.     /* Loops and handlers are scopes for syntactic purposes, but not at run-
  648.      * time. Remove them from depth count.
  649.      */
  650.     out_depth = i - 1;
  651.     for (j = i; j > 0; j--) {
  652.         scope = (Symbol) open_scopes[j];
  653.         blktyp = (int) OVERLOADS(scope);
  654.         if (blktyp == BLOCK_LOOP || blktyp == BLOCK_HANDLER)
  655.             out_depth -= 1;
  656.     }
  657.     N_VAL(node) = (char *) out_depth;
  658. }
  659.  
  660. void abort_statement(Node node)                            /*;abort_statement*/
  661. {
  662.     Node    name_node;
  663.     Fortup    ft1;
  664.     Symbol    task_obj;
  665.     Set    task_types;
  666.     Symbol    t;
  667.  
  668.     if (cdebug2 > 3)
  669.         TO_ERRFILE("AT PROC :  abort_statement");
  670.  
  671.     FORTUP(name_node = (Node), N_LIST(node), ft1);
  672.         adasem(name_node);
  673.         find_old(name_node);
  674.         valid_task_name(name_node);
  675.         task_types = N_PTYPES(name_node);
  676.  
  677.         if (set_size(task_types) == 0)        /* Previous error*/
  678.             continue;
  679.         else if (!is_task_type( (t = (Symbol)set_arb (task_types), t) ) ) {
  680.             /* Access type not valid here.*/
  681. #ifdef ERRNUM
  682.             errmsgn(475, 476, name_node);
  683. #else
  684.             errmsg(" expect task name is ABORT statement", "9.10", name_node);
  685. #endif
  686.             continue;
  687.         }
  688.         else
  689.             resolve2(name_node, t);
  690.  
  691.         if (N_KIND(name_node) == as_simple_name
  692.           && NATURE(task_obj = N_UNQ(name_node)) == na_task_type ) {
  693.         /* This is a reference to the task currently executing the body.
  694.          * replace the name of the task type by its run-time identity.
  695.          */
  696.             if (in_open_scopes(task_obj))
  697.                 N_UNQ(name_node) = dcl_get(DECLARED(task_obj), "current_task");
  698.             else {
  699. #ifdef ERRNUM
  700.                 errmsgn(477, 476, name_node);
  701. #else
  702.                 errmsg("Invalid task type in ABORT statement", "9.10",
  703.                   name_node);
  704. #endif
  705.             }
  706.         }
  707.     ENDFORTUP(ft1);
  708. }
  709.